home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / database / bltp18.zip / PEZCREAT.BAS < prev    next >
BASIC Source File  |  1994-10-10  |  6KB  |  231 lines
  1. '$DIM ALL
  2. DECLARE FUNCTION EzCreateDXB% (Filename AS STRING * 80, NoFields%, FieldInfo$())
  3.  
  4. DEFINT A-Z
  5. $LINK "PBULLET.PBL"
  6. $INCLUDE "PBULLET.BI"
  7. $LINK "NOATEXIT.OBJ"
  8.  
  9. '10-Oct-94 -chh
  10. 'first test program for Bullet for PB3 (initial modifications from QB to PB3
  11. 'by j.fuller@genie.geis.com (James C. Fuller), August 1994)
  12. '-
  13. 'this program really doesn't do anything but create a DBF data file
  14. '-
  15. 'things to watch for are: VARSEG/VARPTR require fixed-length strings (use
  16. 'STRSEG/STRPTR for variable-length strings (handle-based strings)
  17. '--
  18. 'To create an EXE: compile from PB.EXE
  19.  
  20. DIM DFP AS DOSFilePack
  21. DIM MP AS MemoryPack
  22. DIM IP AS InitPack
  23. DIM EP AS ExitPack
  24. DIM CDP AS CreateDataPack
  25. DIM OP AS OpenPack
  26. DIM DP AS DescriptorPack
  27.  
  28. dim i as integer
  29. DIM level AS INTEGER
  30. DIM stat AS INTEGER
  31. DIM QBHeap AS LONG
  32. DIM NoFields AS INTEGER
  33. DIM FieldInfo(1:1) AS STRING
  34. DIM HandDAT AS INTEGER
  35.  
  36. dim NameDAT as string * 80    'fixed-length required when using VARPTR/SEG
  37. NameDAT = "EZ_TEST.DBF" + CHR$(0)
  38.  
  39. level = 100
  40. MP.Func = %MemoryXB
  41. stat = BULLET(MP)
  42.  
  43. IF MP.Memory < 49152 THEN
  44.    QBheap& = SETMEM(-50000)  'this is not the best way to do this
  45.    MP.Func = %MemoryXB         'should only release 49152-MP.memory+fudge
  46.    stat = BULLET(MP)         'close enough for right now
  47.    IF MP.Memory < 49152 THEN stat = 8: GOTO Abend  'actually could use less
  48. END IF
  49.  
  50.  
  51. level = 110
  52. IP.Func = %InitXB
  53. IP.JFTmode = 0
  54. stat = BULLET(IP)
  55. IF stat THEN GOTO Abend
  56.  
  57. level = 120
  58. EP.Func = %AtExitXB
  59. stat = BULLET(EP)
  60.  
  61. level = 130
  62. DFP.Func = %DeleteFileDOS
  63. DFP.FilenamePtrOff = VARPTR(NameDAT)
  64. DFP.FilenamePtrSeg = VARSEG(NameDAT)
  65. stat = BULLET(DFP)
  66.  
  67. 'this is the simplified method to create BULLET data files
  68. 'simple in that you just use a string array with each element of the array
  69. 'set to the corresponding field info for the DBF data record
  70.  
  71. level = 1000
  72. NoFields = 4
  73. REDIM FieldInfo$(1 TO NoFields)
  74. FieldInfo$(1) = "LASTNAME,C,19,0"
  75. FieldInfo$(2) = "FIRSTNAME,C,15,0"
  76. FieldInfo$(3) = "BIRTHDATE,D,8,0"
  77. FieldInfo$(4) = "SALARY,N,10,2"
  78. stat = EzCreateDXB(NameDAT, NoFields, FieldInfo$())
  79. IF stat THEN GOTO Abend
  80.  
  81. 'just open it up and print out the field descriptors to the data file just reated
  82.  
  83. level = 1010
  84. OP.Func = %OpenDXB
  85. OP.FilenamePtrOff = VARPTR(NameDAT)
  86. OP.FilenamePtrSeg = VARSEG(NameDAT)
  87. OP.ASmode = %ReadWrite + %DenyNone
  88. stat = BULLET(OP)
  89. IF stat THEN GOTO Abend
  90. HandDAT = OP.Handle
  91.  
  92. level = 1020
  93. DP.Func = %GetDescriptorXB
  94. DP.Handle = HandDAT
  95. PRINT
  96. PRINT "FieldName  T  L  D"
  97. PRINT "---------  - -- --"
  98. FOR i = 1 TO NoFields
  99.    DP.FieldNumber = i
  100.    stat = BULLET(DP)
  101.    IF stat = 0 THEN
  102.       PRINT DP.FD.FieldName; DP.FD.FieldType;
  103.       PRINT ASC(DP.FD.FieldLength); ASC(DP.FD.FieldDC)
  104.    ELSE
  105.       EXIT FOR
  106.    END IF
  107. NEXT
  108.  
  109. PRINT
  110. PRINT "Okay."
  111. EndIt:
  112. EP.Func = %ExitXB
  113. stat = BULLET(EP)
  114. END
  115.  
  116.  
  117. Abend:
  118. PRINT
  119. PRINT "Error:"; stat; "at level"; level; "while performing ";
  120. SELECT CASE level
  121. CASE  = 999
  122.    SELECT CASE level
  123.    CASE 100
  124.       PRINT "heap memory release request of 50K."
  125.    CASE 110
  126.       PRINT "BULLET initialization."
  127.    CASE 120
  128.       PRINT "registering of ExitXB with _atexit."
  129.    CASE ELSE
  130.       PRINT "Preliminaries unknown."
  131.    END SELECT
  132. CASE  <= 1099
  133.    SELECT CASE level
  134.    CASE 1000
  135.       PRINT "data file create."
  136.    CASE 1010
  137.       PRINT "data file open."
  138.    CASE 1020
  139.       PRINT "data get descriptors."
  140.    CASE ELSE
  141.       PRINT "data file unknown, or DOS error."
  142.    END SELECT
  143. CASE ELSE
  144.    PRINT "unknown."
  145. END SELECT
  146. GOTO EndIt
  147.  
  148. FUNCTION EzCreateDXB (Filename AS STRING * 80, NoFields AS INTEGER, FieldInfo() AS STRING)
  149.  
  150. 'example of using modular programming to customize the BULLET API
  151.  'FieldInfo$() is a var-len string array with each element made up as:
  152.  ' FieldInfo$(i) = "FIELDNAME,FIELDTYPE,FIELDLEN,FIELDDC" as in:
  153.  ' FieldInfo$(1) = "LASTNAME,C,19,0"
  154.  ' FieldInfo$(2) = "FIRSTNAME,C,15,0"
  155.  ' FieldInfo$(3) = "BIRTHDATE,D,8,0"
  156.  ' FieldInfo$(4) = "SALARY,N,10,2"
  157.  '   and so on
  158.  
  159. REDIM FieldList(1 TO NoFields) AS FieldDescTYPE
  160.  
  161. DIM CDP AS CreateDataPack
  162.  
  163. DIM TmpStr AS STRING * 32
  164.  
  165. dim i AS INTEGER
  166. dim stat AS INTEGER
  167. dim fldname AS STRING
  168. dim fldtype AS STRING
  169. dim fldlength AS INTEGER
  170. dim flddc AS INTEGER
  171. dim cptr AS INTEGER
  172. dim nptr AS INTEGER
  173.  
  174. FOR i = 1 TO NoFields
  175.    GOSUB ParseInfo
  176.    IF stat THEN EXIT FOR
  177.    FieldList(i).FieldName = fldname$
  178.    FieldList(i).FieldType = fldtype$
  179.    FieldList(i).FieldLength = CHR$(fldlength)
  180.    FieldList(i).FieldDC = CHR$(flddc)
  181. NEXT
  182.  
  183. IF stat = 0 THEN
  184.    CDP.Func = %CreateDXB
  185.    CDP.FilenamePtrOff = VARPTR(Filename)
  186.    CDP.FilenamePtrSeg = VARSEG(Filename)
  187.    CDP.NoFields = NoFields
  188.    CDP.FieldListPtrOff = VARPTR(FieldList(1))
  189.    CDP.FieldListPtrSeg = VARSEG(FieldList(1))
  190.    CDP.FileID = 3
  191.    stat = BULLET(CDP)
  192. END IF
  193.  
  194. EzCreateDXB = stat
  195. EXIT FUNCTION
  196.  
  197. '--------
  198. ParseInfo:
  199. stat = 0
  200. cptr = 1
  201. nptr = 0
  202. TmpStr = LTRIM$(RTRIM$(FieldInfo$(i))) + CHR$(0)
  203. nptr = INSTR(cptr, TmpStr, ",")
  204. IF nptr > cptr THEN
  205.    fldname$ = LTRIM$(RTRIM$(MID$(TmpStr, cptr, nptr - cptr))) + STRING$(11,0)
  206.    cptr = nptr + 1
  207.    nptr = INSTR(cptr, TmpStr, ",")
  208.    IF nptr > cptr THEN
  209.       fldtype$ = LTRIM$(RTRIM$(MID$(TmpStr, cptr, nptr - cptr)))
  210.       cptr = nptr + 1
  211.       nptr = INSTR(cptr, TmpStr, ",")
  212.       IF nptr > cptr THEN
  213.          fldlength = VAL(MID$(TmpStr, cptr, nptr - cptr))
  214.          cptr = nptr + 1
  215.          nptr = INSTR(cptr, TmpStr, CHR$(0))
  216.          IF nptr > cptr THEN
  217.             flddc = VAL(MID$(TmpStr, cptr, nptr - cptr))
  218.          END IF
  219.       END IF
  220.    END IF
  221. END IF
  222. IF nptr <= cptr THEN stat = 243  '(for lack of a better error code...)
  223.  
  224. 'may want to verify that fldname$,fldtype$,fldlength,flddc are within limits
  225.  
  226. RETURN
  227. end function
  228.  
  229.  
  230.  
  231.